home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / think-ref-lookup.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  4.1 KB  |  108 lines  |  [TEXT/CCL2]
  1. ;
  2. ;  think-ref-lookup.lisp
  3. ;
  4. ;  This code enables you to lookup THINK Reference (TM) from Fred editor.
  5. ;  If you load this file, the lookup function ed-think-reference is bound to m-r.
  6. ;
  7. ;  The original code is posted to info-mcl@cambridge.apple.com on 12/1/1993
  8. ;  by Jeffrey B Kane (jbk@world.std.com).
  9. ;  I added some faculties
  10. ;  * to launch THINK Reference (TM) if you have not loaded it yet.
  11. ;  * to get the current S expression and lookup if it is a symbol.
  12. ;  * to handle appleevent-error and display its message to mini-buffer.
  13. ;
  14. ;  And on Bill St. Clair's (bill@cambridge.apple.com) advice, I changed my code
  15. ;  to search THINK Reference (TM) with _PBDTGetAPPL. I referd to his code
  16. ;  in the file cambridge.apple.com /pub/mcl2/contrib/processes.lisp.
  17. ;
  18. ;  Special thanks for Jeffery and Bill.
  19. ;
  20. ;  Masaya UEDA        ueda@shpcsl.sharp.co.jp
  21.  
  22. (eval-when (:compile-toplevel :execute :load-toplevel)
  23.   (require :appleevent-toolkit))
  24.  
  25. (defun %get-creator-path (creator fsspec)
  26.   (let ((devs (directory "*:")))
  27.     (dolist (vrefnum (sort (mapcar 'volume-number devs) #'>))
  28.       (rlet ((pb :DTPBRec
  29.                  :ioNamePtr (%null-ptr)
  30.                  :ioVRefnum vrefnum))
  31.         (when (= (#_PBDTGetPath pb) #$noErr)
  32.           (setf (rref pb :DTPBRec.ioNamePtr)
  33.                 (%inc-ptr fsspec (get-field-offset :fsspec.name))
  34.                 (pref pb :DTPBRec.ioIndex) 0
  35.                 (pref pb :DTPBRec.ioFileCreator) creator)
  36.           (when (= (#_PBDTGetAPPL pb) #$noErr)
  37.             (setf (pref fsspec :fsspec.vRefnum) vrefnum
  38.                   (pref fsspec :fsspec.parID) (pref pb :DTPBRec.ioAPPLParID))
  39.             (return (values))))))))
  40.  
  41. #|
  42. (defun get-creator-path (creator)
  43.   (rlet ((fsspec :fsspec))
  44.     (%get-creator-path creator fsspec)
  45.     (%path-from-fsspec fsspec)))
  46. |#
  47.  
  48. (defun %launch-application (fsspec)
  49.   (rlet ((lpb :LaunchParamBlockRec
  50.               :launchBlockID #$extendedBlock
  51.               :launchEPBLength #$extendedBlockLen
  52.               :launchFileFlags 0
  53.               :launchControlFlags (+ #$launchContinue #$launchNoFileFlags)
  54.               :launchAppSpec fsspec
  55.               :launchAppParameters (%null-ptr)))
  56.     (if (= (#_LaunchApplication lpb) #$noErr)
  57.       (values (rref lpb :LaunchParamBlockRec.launchProcessSN.highLongOfPSN)
  58.               (rref lpb :LaunchParamBlockRec.launchProcessSN.LowLongOfPSN)))))
  59.  
  60. #|
  61. (defun launch-application (filename &aux (pf (probe-file filename)))
  62.   (if pf (rlet ((fsspec :fsspec))
  63.            (with-pstrs ((name (mac-namestring pf)))
  64.              (#_FSMakeFSSpec 0 0 name fsspec))
  65.            (%launch-application fsspec))))
  66. |#
  67.  
  68. (defun think-reference (search-string)
  69.   (with-aedescs (ae target reply)
  70.     (with-pstrs ((pstring search-string))
  71.       (multiple-value-bind (psnhigh psnlow) (find-process-with-signature :|DanR|)
  72.         (unless psnhigh
  73.           (multiple-value-setq (psnhigh psnlow)
  74.             (rlet ((fsspec :fsspec))
  75.               (%get-creator-path :|DanR| fsspec)
  76.               (%launch-application fsspec))))
  77.         (when psnhigh
  78.           (create-psn-target target psnhigh psnlow)
  79.           ;; create an apple event
  80.           (ae-error (#_AECreateAppleEvent
  81.                      :|DanR|
  82.                      :|REF |
  83.                      target
  84.                      #$kAutoGenerateReturnID
  85.                      #$kAnyTransactionID
  86.                      ae))
  87.           ;; stuff it with our parameters
  88.           (ae-error (#_AEPutParamPtr
  89.                      ae
  90.                      #$keyDirectObject
  91.                      #$typeChar
  92.                      (%inc-ptr pstring)
  93.                      (%get-unsigned-byte pstring)))
  94.           ;; send it off
  95.           (send-appleevent ae reply :reply-mode :wait-reply))))))
  96.  
  97. (defmethod ed-think-reference ((fm fred-mixin))
  98.   (let ((sym (ed-current-sexp fm))) 
  99.     (when (and sym (symbolp sym))
  100.       (let ((sn (symbol-name sym)))
  101.         (when (or (char= #\_ (char sn 0)) (char= #\$ (char sn 0)))
  102.           (setq sn (subseq sn 1)))
  103.         (handler-case (think-reference sn)
  104.           (appleevent-error (condition)
  105.                             (format (view-mini-buffer fm) "~a: ~a"
  106.                                     sn condition)))))))
  107.  
  108. (def-fred-command (:meta #\r) ed-think-reference)